home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
5.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
31KB
|
1,147 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
/* Todo:
3-12-86 ds
Modify format of as_return node so that new node of type as_number
put in N_AST3 field to hold depth count formerly kept in N_VAL.
30-oct-84 ds
Note that N_VAL for node produced at end of return_statement()
is different, is now integer giving depth, was tuple of length two.
id is defined in goto_statement but never used
*/
#include "attr.h"
#include "hdr.h"
#include "vars.h"
#include "setp.h"
#include "dclmapp.h"
#include "miscp.h"
#include "errmsgp.h"
#include "dbxp.h"
#include "evalp.h"
#include "nodesp.h"
#include "smiscp.h"
#include "chapp.h"
#define label_unreachable 0
#define label_reachable 1
static void new_symbol(Symbol, int, Symbol, Tuple, Symbol);
static Const get_static_nval(Node);
static void replace_others(Node, Node, int, int);
Symbol slice_type(Node node, int is_renaming) /*;slice_type*/
{
Node array_node, range_node, low_node, high_node, type_node;
Node new_range_node, arg1, arg2, var_node;
Symbol type_name, type_mark, index_name, i_type;
Tuple tup;
int attr_prefix, kind;
/* We must have a subtype for the aggregate to give the bounds */
if (is_renaming) {
var_node = N_AST3(node);
}
else
var_node = N_AST1(node);
array_node = N_AST1(var_node);
range_node = N_AST2(var_node);
kind = N_KIND(range_node);
if (kind == as_simple_name || kind == as_name)
type_name = N_UNQ(range_node);
else {
if (kind == as_subtype) {
type_node = N_AST1(range_node);
new_range_node = N_AST2(range_node);
low_node = N_AST1(new_range_node);
high_node = N_AST2(new_range_node);
}
else if (kind == as_range) {
low_node = N_AST1(range_node);
high_node = N_AST2(range_node);
}
else if (kind == as_attribute) {
/*att_node = N_AST1(range_node); -- not needed in C */
arg1 = N_AST2(range_node);
arg2 = N_AST3(range_node);
/* subtract code for ATTR_FIRST to get T_ or O_ value */
/* recall that in C attribute kind kept in range_node*/
attr_prefix = (int)attribute_kind(range_node)-ATTR_RANGE;
/* 'T' or 'O' */
attribute_kind(range_node) = (char *)((int) attr_prefix+ATTR_FIRST);
low_node = range_node;
high_node = new_attribute_node(attr_prefix+ATTR_LAST,
copy_node(arg1), copy_node(arg2), get_type(range_node));
eval_static(low_node);
eval_static(high_node);
}
else {
errmsg("Unexpected range in slice", "", range_node );
low_node = OPT_NODE;
high_node = OPT_NODE;
}
/* We need the bounds twice, for the slice and for the aggregate
* so we build an anonymous subtype to avoid double evaluation
*/
if (N_KIND(array_node) == as_simple_name
|| N_KIND(array_node) == as_name)
type_mark = TYPE_OF(N_UNQ(array_node));
else
type_mark = N_TYPE(array_node);
type_mark = base_type(type_mark); /* get base type */
index_name = named_atom("slice_index_type");
type_name = named_atom("slice_type");
i_type= (Symbol) index_type(type_mark);
tup = constraint_new(0);
tup[2] = (char *) low_node;
tup[3] = (char *) high_node;
new_symbol(index_name, na_subtype, i_type, tup, ALIAS(i_type));
SCOPE_OF(index_name) = scope_name;
tup = constraint_new(4);
tup[1] = (char *) tup_new1((char *) index_name);
tup[2] = (char *) component_type(type_mark);
new_symbol(type_name, na_subtype, type_mark, tup, ALIAS(type_mark));
SCOPE_OF(type_name) = scope_name;
tup = tup_new(2);
tup[1] = (char *) new_subtype_decl_node(index_name);
tup[2] = (char *) new_subtype_decl_node(type_name);
make_insert_node(node, tup, copy_node(node));
N_AST1(var_node) = array_node;
N_AST2(var_node) = new_name_node(index_name);
copy_span(range_node, N_AST2(var_node));
}
return type_name;
}
static void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
Tuple new_signature, Symbol new_alias) /*;new_symbol*/
{
NATURE(new_name) = new_nature;
TYPE_OF(new_name) = new_type;
SIGNATURE(new_name) = new_signature;
ALIAS(new_name) = new_alias;
dcl_put(DECLARED(scope_name), str_newat(), new_name);
}
Symbol get_type(Node node) /*;get_type*/
{
/*
* GET_TYPE is procedure get_type() in C:
* macro GET_TYPE(node);
* (if N_KIND(node) in [as_simple_name, as_subtype_indic]
* then TYPE_OF(N_UNQ(node))
* }
* else N_TYPE(node) end ) endm;
*/
int nk;
Symbol sym;
nk = N_KIND(node);
if (nk == as_simple_name || nk == as_subtype_indic) {
sym = N_UNQ(node);
if (sym == (Symbol)0) {
#ifdef DEBUG
zpnod(node);
#endif
chaos("get_type: N_UNQ not defined for node");
}
else
sym = TYPE_OF(sym);
}
else
sym = N_TYPE(node);
return sym;
}
void assign_statement(Node node) /*;assign_statement*/
{
Node var_node, exp_node;
Symbol t, t1, t2, ok_sym;
Set t_l, t_left, t_right, ok_types, ook_types;
Forset tiv, tforl, tforr, fs1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : assign_statement");
var_node = N_AST1(node);
exp_node = N_AST2(node);
noop_error = FALSE; /* To clear previous type errors */
adasem(var_node);
find_old(var_node); /* left-hand side is a name.*/
adasem(exp_node);
resolve1(var_node);
t_l = N_PTYPES(var_node);
t_left = set_new(0);
FORSET(t = (Symbol), t_l, tiv);
if (! is_limited_type(t)) t_left = set_with(t_left, (char *) t);
ENDFORSET(tiv);
resolve1(exp_node);
t_right = N_PTYPES(exp_node);
if (noop_error) { /* previous error. */
noop_error = FALSE;
return;
}
ok_types = set_new(0);
FORSET(t1 = (Symbol), t_left, tforl);
FORSET(t2 = (Symbol), t_right, tforr);
if (compatible_types(t1, t2) )
ok_types = set_with(ok_types, (char *) t1);
ENDFORSET(tforr);
ENDFORSET(tforl);
/* For the assignment to be unambiguous, the left-hand and right_hand
* sides must have a single compatible interpretation.
*/
if (set_size(ok_types) == 0) {
if (set_size(t_l) == 1 && set_size(t_left) == 0) {
errmsg("assignment not available on a limited type", "7.4.2",
var_node);
set_free(ok_types);
return;
}
else {
errmsg("incompatible types for assignment", "5.2", node);
set_free(ok_types);
return;
}
}
else if (set_size(ok_types) > 1) { /* ambiguous left-hand side */
remove_conversions(var_node); /* last chance. */
ook_types = ok_types;
ok_types = set_new(0);
FORSET(ok_sym=(Symbol), N_PTYPES(var_node), fs1);
if (set_mem((char *) ok_sym, ook_types))
ok_types = set_with(ok_types, (char *)ok_sym);
ENDFORSET(fs1);
set_free(ook_types);
if (set_size(ok_types) != 1) {
errmsg("ambiguous types for assigment", "5.2", var_node);
set_free(ok_types);
return;
}
}
t1 = (Symbol) set_arb(ok_types); /* Now unique. */
set_free(ok_types);
out_context = TRUE;
resolve2(var_node, t1);
out_context = FALSE;
/*if (N_KIND(var_node) == as_slice && (N_KIND(exp_node) == as_aggregate
||N_KIND(exp_node) == as_string_literal)){*/
/* we don't have to care about the type of the right hand side cf Setl */
if (N_KIND(var_node) == as_slice) {
/* context is constrained, even though type of lhs is base type
* This means that an OTHERS association is allowed.
*/
t1 = slice_type(node,0);
resolve2 (exp_node, t1);
return;
}
if(NATURE(t1) == na_array && N_UNQ(var_node) != (Symbol)0 &&
(NATURE(N_UNQ(var_node))==na_inout || NATURE(N_UNQ(var_node))==na_out))
replace_others(exp_node, var_node, tup_size(index_types(t1)), 1);
resolve2(exp_node, t1);
if (! is_variable(var_node)){
errmsg("left-hand side in assignment is not a variable", "5.2",
var_node);
return;
}
if (is_array(t1) ) {
/* array assignments are length_checked in the interpreter, and don't
* carry a qualification.
*/
;
}
else if (!in_qualifiers(N_KIND(exp_node))) {
/* a constraint check on the right hand side may be needed.*/
N_TYPE(exp_node) = base_type(t1);
apply_constraint(exp_node, t1);
}
eval_static(var_node);
eval_static(exp_node);
noop_error = FALSE; /* clear error flag */